home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / intrfc70.zip / UTIL.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1994-03-16  |  3.3 KB  |  181 lines
  1. unit util;
  2. {$I SWITCHES.INC}
  3. interface
  4.   uses dos;
  5.  
  6.   var
  7.     last_file_size : longint;
  8.  
  9.   function minw(w1,w2:word):word;
  10.  
  11.   function add_only_offset(p:pointer; add:word):pointer;
  12.  
  13.   function upper(const s:string):string;
  14.  
  15.   function ptr_diff(p1,p2:pointer):longint;
  16.  
  17.   procedure read_file(filename: string;var buffer:pointer;
  18.                      offset:longint; size:word);
  19.   { Attempts to read a file into buffer; returns nil if there was a problem }
  20.  
  21.   function roundup(n,r:word):word;
  22.  
  23.   { error routines }
  24.  
  25.   procedure PrintStrErr(const S: String);
  26.  
  27.   procedure WriteError(const S:string);
  28.  
  29.   procedure WriteOutput(const S:string);
  30.  
  31.   procedure HaltError(const S:string);
  32.  
  33.   procedure ErrorStatus;
  34.  
  35. implementation
  36.  
  37. uses Memory;
  38.  
  39. function minw(w1,w2:word):word;
  40. begin
  41.   if w1<w2 then
  42.     minw := w1
  43.   else
  44.     minw := w2;
  45. end;
  46.  
  47. function add_only_offset(p:pointer; add:word):pointer;
  48. begin
  49.   add_only_offset := ptr(seg(p^),ofs(p^)+add);
  50. end;
  51.  
  52. function upper(const s:string):string;
  53. var
  54.   i:integer;
  55.   result : string;
  56. begin
  57.   result[0] := s[0];
  58.   for i:=1 to length(s) do
  59.     result[i] := upcase(s[i]);
  60.   upper := result;
  61. end;
  62.  
  63. function ptr_diff(p1,p2:pointer):longint;
  64. begin
  65.   if seg(p1^)<>seg(p2^) then
  66.     HaltError('Internal error : util.ptr_diff');
  67.   ptr_diff :=  ofs(p1^) - ofs(p2^);
  68. end;
  69.  
  70. procedure read_file(filename: string;var buffer:pointer;
  71.                    offset:longint; size:word);
  72. { Attempts to read a file into buffer; returns nil if there was a problem }
  73. var
  74.   f:file;
  75.   try_size : longint;
  76. begin
  77.   assign(f,filename);
  78.   buffer := nil;
  79.   {$i-} reset(f,1); {$i+}
  80.   if ioresult <> 0 then
  81.     exit;
  82.   last_file_size := filesize(f);
  83.   try_size := last_file_size-offset;
  84.   if try_size < size then
  85.     size := try_size;
  86.   try_size := size;
  87.   if size=0 then
  88.     exit;
  89.   if size > 65521 then
  90.   begin
  91.     WriteError('File size too large.  File not read.');
  92.     exit;
  93.   end;
  94.   if maxavail < size then
  95.   begin
  96.     WriteError('Out of memory.  File '+filename+' not read.');
  97.     exit;
  98.   end;
  99.   buffer:=MemAllocSeg(size);
  100.   seek(f,offset);
  101.   {$I-}
  102.   blockread(f,buffer^,try_size,size);
  103.   {$I+}
  104.   if size<>try_size then
  105.   begin
  106.     freemem(buffer,try_size);
  107.     buffer:=nil;
  108.   end;
  109.   close(f);
  110. end;
  111.  
  112. function roundup(n,r:word):word;
  113. begin
  114.   roundup := r*((n+r-1) div r);
  115. end;
  116.  
  117. function IsDevice(var F:text):Boolean; assembler;
  118. asm
  119.    les   di,F
  120.    mov   bx,TextRec(ES:[DI]).Handle
  121.    mov   ax,4400h
  122.    int   21h
  123.    xor   ax,ax
  124.    and   dx,0080h
  125.    je    @@0
  126.    inc   ax
  127. @@0:
  128. end;
  129.  
  130. procedure PrintStrErr(const S: String); assembler;
  131. asm
  132.     PUSH    DS
  133.         LDS    SI,S
  134.     CLD
  135.     LODSB
  136.     XOR    AH,AH
  137.         XCHG    AX,CX
  138.         MOV    AH,40H
  139.         MOV    BX,1
  140.         MOV    DX,SI
  141.         INT    21H
  142.         POP    DS
  143. end;
  144.  
  145. procedure WriteOutput(const S:string);
  146. begin
  147.   Writeln(output,S);
  148.   if not IsDevice(output) then
  149.     PrintStrErr(S+#13#10);
  150. end;
  151.  
  152. procedure HaltError(const S:string);
  153. begin
  154.   WriteOutput(S);
  155.   WriteOutput('Halting.');
  156.   Halt;
  157. end;
  158.  
  159. const Errors:longint=0;
  160.  
  161. procedure WriteError(const S:string);
  162. begin
  163.   WriteOutput(S);
  164.   Inc(Errors);
  165. end;
  166.  
  167. procedure ErrorStatus;
  168. var S:string;
  169. begin
  170.   if Errors<>0 then
  171.   begin
  172.     Str(Errors,S);
  173.     WriteOutput('');
  174.     WriteOutput(' Errors :'+S);
  175.   end;
  176. end;
  177.  
  178. end.
  179.  
  180.  
  181.